home *** CD-ROM | disk | FTP | other *** search
/ Aminet 6 / Aminet 6 - June 1995.iso / Aminet / text / misc / mk3d1_1.lha / make3d / mk3d.e < prev    next >
Encoding:
Text File  |  1995-03-03  |  7.6 KB  |  332 lines
  1. MODULE 'dos/rdargs', 'dos/dostags', 'utility/tagitem', 'dos/dos',
  2.        'other/stderr','other/stayrandom'
  3.  
  4. ENUM OK,MEM,OPEN,READ,ARGS,CTRLC,ARG_ERR=0,ARG_IN,ARG_OUT,ARG_SIM,
  5.      ARG_MOO,ARG_MAX
  6.  
  7. RAISE MEM   IF List()=NIL,
  8.       MEM   IF String()=NIL,
  9.       OPEN  IF Open()=NIL,
  10.       ARGS  IF ReadArgs()=NIL,
  11.       "^C"  IF CtrlC()=TRUE
  12.  
  13. PROC randasc(easy)
  14. DEF test=0
  15.  SELECT easy
  16.   CASE 0
  17.    RETURN "A" + Rnd(26)
  18.   CASE 1
  19.    RETURN IF Rnd(100)>50 THEN "A" + Rnd(26) ELSE "a" + Rnd(26)
  20.   CASE 2
  21.    test:=Rnd(100)
  22.    IF test < 33 THEN RETURN "A" + Rnd(26)
  23.    IF test < 66 THEN RETURN "a" + Rnd(26)
  24.    RETURN "0" + Rnd(10)
  25.   CASE 4
  26.    test:=Rnd(100)
  27.    IF test < 50 THEN RETURN "!" + Rnd(94)
  28.    test:=Rnd(94) + 161
  29.    IF test>172 THEN INC test
  30.    RETURN test
  31.   DEFAULT
  32.    RETURN "!" + Rnd(92)
  33.  ENDSELECT
  34. ENDPROC
  35.  
  36.  
  37. PROC main() HANDLE
  38.  
  39.  DEF in=0,out=0,gramwidth=0,xdepth=0,col,pattern,arg_format,
  40.      patternbeg,patternend,buf,template,xtrahelp,myarg:PTR TO rdargs,
  41.      patterncur,indata,pat,n,p=0,del,mv,ins,rdarg:PTR TO rdargs,
  42.      args[ARG_MAX]:LIST,easy=3,tmp
  43.  myarg := pattern := indata := rdarg := 0
  44.  err_Name('mk3d')
  45.  template := 'ERR=ERRORS/K,IN=INPUT/A,OUT=OUTPUT,S=SIMPLE/N,MOO/S'
  46.  xtrahelp := 'Usage: mk3d IN "filename" [OUT "filename"] [ERR "filename"]\n' +
  47.  '            [S "number"]\n\n' +
  48.  ' IN specifies a mandatory input file to read for a template.\n' +
  49.  'OUT specifies an optional output file to write.\n' +
  50.  'ERR specifies an optional error file to write (instead of stderr).\n' +
  51.  '  S specifies how simple the characters should be, by this chart:\n\n' +
  52.  '      0 = Only uppercase characters\n' +
  53.  '      1 = Upper/lowercase characters\n' +
  54.  '      2 = AlphaNumeric characters\n' +
  55.  '      3 = AlphaNumeric characters with symbols (default)\n' +
  56.  '      4 = Anything printable via Topaz font\n\n' +
  57.  'For information about the IN file''s format, please, read mk3d.doc.\n' +
  58.  'NOTE: This program based on the same written for MS-DOS.\n' +
  59.  '      Modified somewhat heavily by Joseph E. Van Riper III\n' +
  60.  '      of the Cheese Olfactory Workshop.\n\n' 
  61.   
  62.  buf:=String(80)
  63.  
  64. /* Handle the arguments (somehow)
  65.  */
  66.  args[ARG_IN]:=0
  67.  args[ARG_OUT]:=0
  68.  args[ARG_ERR]:=0
  69.  args[ARG_SIM]:=0
  70.  args[ARG_MOO]:=FALSE
  71.  myarg:=AllocDosObject(DOS_RDARGS, TAG_DONE)
  72.  myarg.exthelp := xtrahelp
  73.  arg_format:=template
  74.  rdarg:=ReadArgs(arg_format,args,myarg)
  75.  
  76.  FOR del:=0 TO ARG_MAX-1
  77.   CtrlC()
  78.   SELECT del
  79.    CASE ARG_IN
  80.     IF args[ARG_IN]<>0
  81.      in := Open(args[ARG_IN], MODE_OLDFILE)
  82.      SetIoErr(0)
  83.      err_WriteF('IN: \s\n',[args[ARG_IN]])
  84.     ELSE
  85.      Raise(ARGS)
  86.     ENDIF
  87.    CASE ARG_OUT
  88.     IF StrLen(args[ARG_OUT]) AND (args[ARG_OUT]<>0)
  89.      out := Open(args[ARG_OUT], MODE_NEWFILE)
  90.      SetIoErr(0)
  91.      err_WriteF('OUT: \s\n',[args[ARG_OUT]])
  92.     ELSE
  93.      out := stdout
  94.     ENDIF
  95.    CASE ARG_ERR
  96.     IF StrLen(args[ARG_ERR]) AND (args[ARG_ERR]<>0)
  97.      err_New(args[ARG_ERR])
  98.     ENDIF
  99.    CASE ARG_SIM
  100.     tmp:=args[ARG_SIM]
  101.     IF tmp
  102.      easy := ^tmp
  103.     ELSE
  104.      easy := 3
  105.     ENDIF
  106.    CASE ARG_MOO
  107.     IF args[ARG_MOO]
  108.      WriteF('\nCongrads.. you''re very observant!\n' +
  109.             'Unfortunately, all you get is a nice little:\n' +
  110.             'Mooooooooo.\n')
  111.      ENDIF
  112.    DEFAULT
  113.     Raise('$VER: mk3d 1.1 (3.3.95)')
  114.   ENDSELECT
  115.  ENDFOR
  116. /* READ IN GRAMWIDTH: STEREOGRAM WIDTH (INCLUDE 2*XDEPTH + FEW MORE)
  117.  */
  118.  
  119.  IF ReadStr(in, buf) = TRUE THEN Raise(READ)
  120.  gramwidth := Val(buf,NIL)
  121.  SetIoErr(0)
  122.  err_WriteF('Gramwidth: \d\n',[gramwidth])
  123.  IF ( (gramwidth < 1) OR (gramwidth > 512) )
  124.   Raise("GRAM")
  125.  ENDIF
  126.  
  127.  /* READ IN XDEPTH: LENGTH OF REPEATING BG PATTERN
  128.   */
  129.  IF ReadStr(in, buf) = TRUE THEN Raise(READ)
  130.  xdepth := Val(buf,NIL)
  131.  SetIoErr(0)
  132.  err_WriteF('Xdepth: \d\n',[xdepth])
  133.  IF ( (xdepth < 5) OR (xdepth > 64) OR ((xdepth*2) > gramwidth) )
  134.   Raise("XDEP")
  135.  ENDIF
  136.  
  137.  /* PRINT FUSION X'S
  138.   */
  139.  FOR col:=1 TO gramwidth-1
  140.   CtrlC()
  141.   FputC( out, IF Mod(col,xdepth) THEN " " ELSE "X" )
  142.  ENDFOR
  143.  FputC( out, 10 )
  144.  
  145.  
  146.  /* SEED RANDOM NUMBER GENERATOR (if desired)
  147.   */
  148.  
  149.  stayrandom()
  150.  
  151.  pattern := List(xdepth+1)
  152.  indata := String(gramwidth+1)
  153.  
  154.  /* IF NOT EOF, GET A LINE OF DATA
  155.   */
  156.  WHILE (ReadStr(in,indata)<>-1)
  157.   /* GENERATE A NEW RANDOM PATTERN,
  158.    * OUTPUT FULL PATTERN TO START THE LINE
  159.    */
  160.   CtrlC()
  161.   FOR pat:=0 TO xdepth
  162.    CtrlC()
  163.    pattern[pat] := randasc(easy)
  164.    IF pat <> xdepth THEN FputC ( out, pattern[pat] )
  165.   ENDFOR
  166.  
  167.   /* N IS VALUE OF NEXT CHAR, P IS VALUE OF PREVIOUS CHAR
  168.    */
  169.  
  170.   patterncur := patternbeg := col := p := n := 0
  171.   patternend := xdepth
  172.  
  173.   /* WHILE NOT EOL
  174.    */
  175.   WHILE (col < (gramwidth-xdepth))
  176.    /* SET N TO VALUE OF NEXT CHAR
  177.     */
  178.    CtrlC()
  179.    IF ( (indata[col] >= "1") AND (indata[col] <= "9") )
  180.     n := indata[col] - "0"
  181.     SetIoErr(0)
  182.     err_WriteF('\d',[n])
  183.    ELSE
  184.     n := 0
  185.     SetIoErr(0)
  186.     err_WriteF(' ')
  187.    ENDIF
  188.  
  189.    /* IF NEXT VALUE IS NOT THE SAME AS THE PREV VALUE (LEVEL SHIFT)
  190.     */
  191.    IF (n <> p)
  192.     /* IF SHIFTING 'UP' (CLOSER TO USER)
  193.      */
  194.     IF (n > p)
  195.      /* DEL NEXT N-P BITS IN PATTERN
  196.       */
  197.      FOR del := 0 TO (n-p-1)
  198.       CtrlC()
  199.       mv := patterncur
  200.       REPEAT
  201.        CtrlC()
  202.        pattern[mv]:=pattern[mv+1]
  203.        INC mv
  204.       UNTIL (mv=(patternend+1))
  205.       DEC patternend
  206.       IF (patterncur = patternend) THEN patterncur := patternbeg
  207.      ENDFOR
  208.     /* SHIFTING 'DOWN' (AWAY FROM USER)
  209.      */
  210.     ELSE
  211.      /* INSERT P-N RANDOM BITS INTO PATTERN
  212.       */
  213.      FOR ins := 0 TO (p-n-1)
  214.       CtrlC()
  215.       FOR mv:=patternend+2 TO patterncur+1 STEP -1
  216.        CtrlC()
  217.        pattern[mv]:=pattern[mv-1]
  218.       ENDFOR
  219.       pattern[patterncur]:=randasc(easy)
  220.       INC patternend
  221.      ENDFOR
  222.     ENDIF
  223.  
  224.     /* UPDATE P
  225.      */
  226.     p := n
  227.  
  228.     /* OUTPUT NEXT CHAR IN RANDOM PATTERN
  229.      */
  230.     FputC(out,pattern[patterncur])
  231.     
  232.    /* NEXT VALUE IS SAME AS PREVIOUS VALUE
  233.     */
  234.    ELSE
  235.     /* OUTPUT NEXT CHAR IN RANDOM PATTERN
  236.      */
  237.     FputC(out,pattern[patterncur])
  238.     
  239.    ENDIF
  240.   /* ADVANCE PATTERN PTR
  241.    */
  242.    INC patterncur
  243.    IF (patterncur = patternend) THEN patterncur := patternbeg
  244.  
  245.   /* ADVANCE INPUT PTR
  246.    */
  247.    INC col
  248.   ENDWHILE
  249.   /* END OF LINE: OUTPUT NEWLINE CHAR, CLEAN LINE BUFFER
  250.    */
  251.   Fputs(out,'\n')
  252.   SetIoErr(0)
  253.   err_WriteF('\n')
  254.   FOR del:=0 TO gramwidth+1
  255.    indata[del]:=0
  256.   ENDFOR
  257.  ENDWHILE
  258.  
  259.  /* END OF FILE: DONE, CLOSE UP
  260.   */
  261.  Raise(0)
  262.  
  263. EXCEPT
  264.  
  265.  IF in THEN Close(in)
  266.  IF out AND (out<>stdout) THEN Close(out)
  267.  IF pattern THEN Dispose(pattern)
  268.  IF indata THEN Dispose(indata)
  269.  IF rdarg THEN FreeArgs(rdarg)
  270.  IF myarg THEN FreeDosObject(DOS_RDARGS,myarg)
  271.  
  272.  p := 'something (maybe internal error).\n'
  273.  
  274.  SELECT exception
  275.  
  276.   CASE OK
  277.    p := 0
  278.   CASE OPEN
  279.    IF (in=NIL)
  280.     err_WriteF('Cannot open infile.\n')
  281.    ELSEIF (out=NIL)
  282.     err_WriteF('Cannot open outfile.\n')
  283.    ELSE
  284.     err_WriteF('Cannot open \s.',[p])
  285.    ENDIF
  286.    p := 10
  287.   CASE MEM
  288.    err_WriteF('Unable to allocate memory for ')
  289.    IF (pattern=NIL)
  290.     err_WriteF('pattern.\n')
  291.    ELSEIF (indata=NIL)
  292.     err_WriteF('incoming data.\n')
  293.    ELSE
  294.     err_WriteF(p)
  295.    ENDIF
  296.    p := 20
  297.   CASE "GRAM"
  298.    err_WriteF('Gramwidth value must be between 1 and 512.\n')
  299.    p := 10
  300.   CASE "XDEP"
  301.    err_WriteF('Xdepth value must be between 5 and 64\n' +
  302.           '(and less than half the stereogram width).\n')
  303.    p := 10
  304.   CASE ARGS
  305.    IF CtrlC()
  306.     SetIoErr(0)
  307.     err_WriteF('mk3d: ***Break\n')
  308.     n:=0
  309.     p:=20
  310.    ELSE
  311.     err_WriteF(xtrahelp)
  312.     p := 5
  313.    ENDIF
  314.   CASE READ
  315.    err_WriteF('Error while reading input file.\n')
  316.    p := 10
  317.   CASE "^C"
  318.    err_WriteF('mk3d: ***Break\n')
  319.    n := 0
  320.    p := 20
  321.   CASE "GURU"
  322.    err_WriteF('GURU: $\h\n',exceptioninfo)
  323.    n := 0
  324.    p := 20
  325.   DEFAULT
  326.    err_WriteF('Extremely Awful Internal Error.  Mention following to author:\n')
  327.    err_WriteF('\s\n',[exception])
  328.    p := 20
  329.  ENDSELECT
  330.  err_Dispose()
  331. ENDPROC p
  332.